Windows 6-Pak - Disc 5/Windows 6-Pak (InfoMagic) (Disc 5) (1999).ISO/Misc-Programming-Tools/regen01.exe/SOURCE.ZIP/main.pas

Pascal/Delphi Source File | 1998-09-02 | 20.3 KB | 805 lines

unit main;

{Source Code for Registry Enumerator (copy right) Greg Lorriman 1998.

Compiled with Delphi2.

email :[e-mail]  web : http://www.lorriman.demon.co.uk

You will also need the RxLib components and Eric Fookes's super label components.
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Ef_Edit, ComCtrls, ExtCtrls, Nestinfo, Buttons, Menus,registry,
  Placemnt, FileOp;



type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    Panel5: TPanel;
    RichEdit1: TRichEdit;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    SaveAs1: TMenuItem;
    Save1: TMenuItem;
    Open1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    Edit1: TMenuItem;
    Options1: TMenuItem;
    Help1: TMenuItem;
    copy1: TMenuItem;
    N2: TMenuItem;
    Selectall1: TMenuItem;
    TextOnly1: TMenuItem;
    DefaultsOnly1: TMenuItem;
    HelpTopics1: TMenuItem;
    N3: TMenuItem;
    AboutRegenumerator1: TMenuItem;
    Panel4: TPanel;
    btnEnum: TButton;
    sbStop: TSpeedButton;
    StatusBar1: TStatusBar;
    FormStorage1: TFormStorage;
    Fullkeypaths1: TMenuItem;
    N4: TMenuItem;
    Other1: TMenuItem;
    N5: TMenuItem;
    OpenRegedit1: TMenuItem;
    SaveDialog1: TSaveDialog;
    OpenDialog1: TOpenDialog;
    Paste1: TMenuItem;
    EditPopUp: TPopupMenu;
    Bold1: TMenuItem;
    Tools1: TMenuItem;
    BackupRegistry1: TMenuItem;
    Panel6: TPanel;
    cbxMaxDepth: TLblComboBox;
    el_cbxMaxDepth: TEnhLabel;
    Panel7: TPanel;
    cbxKey: TLblComboBox;
    el_cbxKey: TEnhLabel;
    N6: TMenuItem;
    Find1: TMenuItem;
    FindNext1: TMenuItem;
    Copy2: TMenuItem;
    procedure btnEnumClick(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure TextOnly1Click(Sender: TObject);
    procedure DefaultsOnly1Click(Sender: TObject);
    procedure AboutRegenumerator1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure sbStopClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Fullkeypaths1Click(Sender: TObject);
    procedure Selectall1Click(Sender: TObject);
    procedure copy1Click(Sender: TObject);
    procedure Other1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure OpenRegedit1Click(Sender: TObject);
    procedure Open1Click(Sender: TObject);
    procedure SaveAs1Click(Sender: TObject);
    procedure Save1Click(Sender: TObject);
    procedure Edit1Click(Sender: TObject);
    procedure Paste1Click(Sender: TObject);
    procedure Bold1Click(Sender: TObject);
    procedure BackupRegistry1Click(Sender: TObject);
    procedure HelpTopics1Click(Sender: TObject);
    procedure cbxMaxDepthChange(Sender: TObject);
    procedure Stop1Click(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Find1Click(Sender: TObject);
    procedure FindNext1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure Copy2Click(Sender: TObject);
    procedure EditPopUpPopup(Sender: TObject);
  private

   addToResults : boolean;
   indentVal : integer;
   maxDepth : string;

    filename : string;
   firstsave : boolean;

   searchWord : string;

   procedure setBold;

  public


//although the following funcitons are methods this is only to aid the status bar update
//the code that would need removing can be skipped by removing the ASMETHOD define
//Which also explainsthe presence of a couple of global variables;
   procedure regEnumerate(keyStr : string;DefaultsOnly, TextOnly, fullpath : boolean;
        indent,maxDepth : integer;sl : TStrings);
    procedure regprocesskey(key : string; DefaultsOnly, TextOnly, fullpath : boolean;
       indent,maxDepth : integer; reg : TRegistry;sl : TStrings);
    procedure findWord;

  end;

var
  Form1: TForm1;

//general stuff
function extractRootKey(str : string):HKEY;
function getKeyName(key : string):string;
function regIntToStr(const i : integer):string;
function iifStr(cond : boolean;t,f : string):string;
function trimchar(const s : string; const c :char):string;
function getDesktopFolder:string;
function createIndent(size, multiplier : integer):string;
procedure checkforstop;

implementation

{$R *.DFM}

{$DEFINE ASMETHOD}

uses strutils,about,okcancl2,inifiles,filectrl;

//following is global to aid extraction of methods from class
const stop : boolean=false;

procedure TForm1.btnEnumClick(Sender: TObject);
var
    strlist : TStringlist;
   cntr : integer;
   maxDepthVal,num : integer;
begin
    stop:=false;

//validate max depth
      try
       if cbxMaxDepth.text<>'(no limit)' then
          num:=strtoint(cbxMaxDepth.text);
       if num<0 then
           abort;
   except
       raise exception.create('Max depth must be 0, positive number or (no limit)');
   end;

   maxDepth:=cbxMaxDepth.text;

//update combo list
    with cbxKey do begin
       if text<>'' then
          if items.indexof(text)=-1 then
               items.insert(0,text);
       while items.count>8 do
           items.delete(items.count-1);
    end;


  strlist:=TStringlist.create;
  if not addtoresults then
      richedit1.lines.clear;

//disable controls
  cbxKey.enabled:=false;
  btnEnum.enabled:=false;
  file1.enabled:=false;
  edit1.enabled:=false;
  options1.enabled:=false;
  help1.enabled:=false;
  sbStop.enabled:=true;
  cbxMaxDepth.enabled:=false;
  tools1.enabled:=false;

//work out max recursive depth
    if maxDepth='(no limit)' then
       maxDepthVal:=high(integer)
   else
       maxDepthVal:=strtoint(maxdepth);
  try

         regEnumerate(trimchar(trim(cbxKey.text),'\'),
              DefaultsOnly1.checked,TextOnly1.checked,Fullkeypaths1.checked,indentVal,maxDepthVal,strlist);

       statusbar1.panels.items[0].text:='Updating display (please wait)';
      try
      try
      richedit1.lines.beginupdate;
      for cntr:=0 to strlist.count-1 do begin
         checkforstop;
         //assign would have been easier? The stop button doesn't work and it takes ages.
         richedit1.lines.add(strlist[cntr]);
      end;
      finally
       richedit1.lines.endupdate;
      end;
      except
       richedit1.lines.clear;
      end;

  finally
        statusbar1.panels.items[0].text:='Processing key :';
          strlist.free;
       cbxKey.enabled:=true;
       btnEnum.enabled:=true;
       sbStop.enabled:=false;
       file1.enabled:=true;
       edit1.enabled:=true;
       options1.enabled:=true;
       help1.enabled:=true;
        cbxMaxDepth.enabled:=true;
        tools1.enabled:=true;
       richedit1.selstart:=0;
  end;
end;


//well, we're not multi-threading, are we now?
const recurseCount : integer=0;

procedure TForm1.regEnumerate(keyStr : string; DefaultsOnly, TextOnly,
 fullpath : boolean; indent,maxDepth : integer;sl : TStrings);
var
    reg : TRegistry;
   subKeyStr : string;
begin
    reg:=TRegistry.create;
   try
          sl.add('Enumeration of : '+cbxKey.text);
       sl.add('Options : '+
           iifStr(defaultsonly,'[Defaults only] ','')+
           iifStr(TextOnly,'[Strings only] ','')+
           iifStr(fullpath,'[Full Key Paths]',''));
       sl.add('Values denoted by "@"');
       reg.rootkey:=extractrootkey(keystr);
       if pos('\',keystr)=0 then
           subkeystr:=''
       else begin
             sl.add('');
           subKeyStr:=copy(keyStr,pos('\',keystr),length(keystr)-pos('\',keystr)+1);
       end;
       //next function is recursive
        regProcessKey(trimchar(subkeyStr,'\'),DefaultsOnly,TextOnly,fullpath,indent,maxDepth,reg,sl);
   finally
       reg.closekey;
       reg.free;
    end;
end;

//recursive;
procedure TForm1.regprocesskey(key : string; DefaultsOnly, TextOnly, fullpath : boolean;
    indent,maxDepth : integer;reg : TRegistry;sl : TStrings);
var subkeystrlist,valuelist : TStringlist;
    valuetype : TRegDataType;
   indentStr : string;
   cntr : integer;
begin

      if recurseCount>maxdepth then
          exit;

   inc(recurseCount);

    subkeystrlist:=TStringlist.create;
   valuelist:=TStringlist.create;
   try

        checkforstop;
       if not reg.openkey(key,false) then
           raise exception.create('Error reading key');

       {$ifdef asmethod}
       statusbar1.panels.items[0].text:='Processing key : '+key;
       statusbar1.update;
//       richedit1.defattributes.style:=richedit1.defattributes.style+[fsbold];
       {$endif}

       indentStr:=createIndent(indent,recursecount);
       sl.add('');
       if fullpath then
           sl.add(indentstr+key)
       else
           sl.add(indentstr+getkeyname(key));

       {$ifdef asmethod}
//       richedit1.defattributes.style:=richedit1.defattributes.style-[fsbold];
       {$endif}

       reg.getvaluenames(valuelist);
       valuelist.sort;

       indentStr:=createIndent(indent,recursecount+1);
       for cntr:=0 to valuelist.count-1 do begin
          checkforstop;
          if (cntr=0) and defaultsonly then begin
              if valuelist[cntr]<>'' then begin
              sl.add(indentstr+'@ : [value not set]');
              break;
           end;
          end;

           valuetype:=reg.getdatatype(valuelist[cntr]);
           if (valuetype=rdString) or (valuetype=rdExpandString) then
               sl.add(indentStr+'@'+valuelist[cntr]+' : '+reg.readstring(valuelist[cntr]))
           else if not textonly then begin
               case valuetype of
                   rdUnknown : sl.add(indentStr+'@'+valuelist[cntr]+' : [unkown]');
                   rdInteger : sl.add(indentStr+'@'+valuelist[cntr]+' : [integer] hex : '+
                       regIntToStr(reg.readinteger(valuelist[cntr]))+
                       '  dec : '+inttostr(reg.readinteger(valuelist[cntr])));
                   rdBinary :  sl.add(indentStr+'@'+valuelist[cntr]+' : [binary]');
               end;
           end;
           if (cntr=0) and defaultsonly then
               break;
       end;


       reg.getkeynames(subkeystrlist);
       reg.closekey;
       subkeystrlist.sort;
       for cntr:=0 to subkeystrlist.count-1 do
           regprocesskey(key+'\'+subkeystrlist[cntr],defaultsonly,textonly,fullpath,indent,maxdepth,reg,sl);


   finally
          dec(recurseCount);
       subkeystrlist.free;
       valuelist.free;
       reg.closekey;
      end;
end;



function extractRootKey(str : string):HKEY;
begin
  str:=ExtractWord(1,Str,['\']);
   if uppercase(str)='HKEY_CLASSES_ROOT' then
       result:=HKEY_CLASSES_ROOT
   else if uppercase(str)='HKEY_CURRENT_USER' then
       result:=HKEY_CURRENT_USER
   else if uppercase(str)='HKEY_LOCAL_MACHINE' then
       result:=HKEY_LOCAL_MACHINE
   else if uppercase(str)='HKEY_USERS' then
       result:=HKEY_USERS
   else if uppercase(str)='HKEY_CURRENT_CONFIG' then
       result:=HKEY_CURRENT_CONFIG
   else if uppercase(str)='HKEY_DYN_DATA' then
       result:=HKEY_DYN_DATA
   else begin
       raise exception.create('Root key not recognised');
   end;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
    cbxKey.width:=cbxKey.parent.width-10-cbxKey.left;
end;

procedure TForm1.TextOnly1Click(Sender: TObject);
begin
    with textonly1 do
       checked:=not checked;

end;

procedure TForm1.DefaultsOnly1Click(Sender: TObject);
begin
    with defaultsonly1 do
       checked:=not checked;

end;

procedure TForm1.AboutRegenumerator1Click(Sender: TObject);
begin
    with Taboutbox.create(nil) do begin
    try
       showmodal
   finally
       free;
   end;
   end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    firstsave:=true;
    stop:=false;
   application.showhint:=true;
   with Tinifile.create('regenum.ini') do begin
       try
       indentval:=readinteger('Opts','Indent',5);
       addtoresults:=readbool('Opts','addtoresults',false);
       self.filename:=readstring('General','Filename','');
       bold1.checked:=readbool('General','Bold',true);
       maxDepth:=readstring('Opts','MaxDepth','1');
       finally
           free;
       end;
   end;
   setbold;
end;

procedure TForm1.sbStopClick(Sender: TObject);
begin
    stop:=true;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
stop:=true;
end;

procedure TForm1.Fullkeypaths1Click(Sender: TObject);
begin
    with Fullkeypaths1 do
       checked:=not checked;

end;

function getKeyName(key : string):string;
var
    lastSlashPos : integer;
   cntr : integer;
begin
    if pos('\',key)=0 then
       result:=key
    else begin
       for cntr:=length(key) downto 1 do begin
           lastSlashPos:=cntr;
           if key[cntr]='\' then
               break;
       end;
       result:=copy(key,lastSlashpos+1,length(key)-lastslashpos);
   end;
end;

function createIndent(size, multiplier : integer):string;
var
    s : string;
   len,cntr : integer;
begin;
    len :=size*multiplier;
    setlength(s,len);
   for cntr:=1 to len do
       s[cntr]:=' ';
   result:=s;
end;

function regIntToStr(const i : integer):string;
var
    str,str1,str2 : string;
   spos,cntr : integer;
   x : integer;
begin

//    x:=356;
    str:=format('%x',[i]);
   str1:='00000000';
   spos:=8-length(str);
   for cntr:=1 to length(str) do
       str1[cntr+spos]:=str[cntr];
   str2:='';
   for cntr:=1 to length(str1) do begin
       str2:=str2+str1[cntr];
       if (cntr mod 2)=0 then
           str2:=str2+' ';
   end;
   result:=str2;
end;

function iifStr(cond : boolean;t,f : string):string;
begin
    if cond then
       result:=t
   else
       result:=f;
end;

function trimchar(const s : string; const c :char):string;
var
  I, L: Integer;
begin
  L := Length(S);
  I := 1;
  while (I <= L) and (S[I] = c) do Inc(I);
  if I > L then Result := '' else
  begin
    while S[L] = c do system.Dec(L);
    Result := Copy(S, I, L - I + 1);
  end;
end;


procedure TForm1.Selectall1Click(Sender: TObject);
begin
richedit1.selectall;
end;

procedure TForm1.copy1Click(Sender: TObject);
begin
richedit1.copytoclipboard;
end;

procedure TForm1.Other1Click(Sender: TObject);
begin
    with TOKRightDlg.create(nil) do begin
   try
       cbAddToResults.checked:=addtoresults;
       edIndent.text:=inttostr(indentVal);
//       cbxMaxDepth.text:=maxDepth;
       if showmodal=mrOk then begin
           addtoresults:=cbAddToResults.checked;
           indentVal:=strtoint(edIndent.text);
//           maxDepth:=cbxMaxDepth.text;
       end;
   finally
       free;
   end;
   end;

end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
   with Tinifile.create('regenum.ini') do begin
       try
       writeinteger('Opts','Indent',indentval);
       writebool('Opts','addtoresults',addtoresults);
       writestring('General','Filename',self.filename);
       writestring('Opts','MaxDepth',maxDepth);
       writebool('General','Bold',bold1.checked);
       finally
           free;
       end;
   end;

end;

procedure TForm1.OpenRegedit1Click(Sender: TObject);
begin
    winexec('regedit.exe',sw_SHOW);
end;

procedure TForm1.Open1Click(Sender: TObject);
var
    folder : string;
begin
   if filename='' then
       folder:=getdesktopfolder
   else
       folder:=extractfilepath(filename);
   with opendialog1 do begin
       initialdir:=folder;
       filename:=self.filename;
       if execute then begin
           richedit1.lines.loadfromfile(filename);
           self.filename:=filename;
           caption:='REgistry enumerator : '+extractfilename(filename);
       end;
   end;
end;

procedure TForm1.SaveAs1Click(Sender: TObject);
var
    folder : string;
begin
   if filename='' then
       folder:=getdesktopfolder
   else
       folder:=extractfilepath(filename);

   with savedialog1 do begin
       initialdir:=folder;
      filename:=self.filename;
      if execute then begin
          richedit1.lines.savetofile(filename);
       firstsave:=false;
       caption:='Registry enumerator : '+extractfilename(filename);
       self.filename:=filename;
      end;
   end;
end;


function getDesktopFolder:string;
begin
    with TRegistry.create do begin
       try
       try
       rootkey:=HKEY_USERS;
       if openkey('.Default\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders',false) then
           result:=readstring('Desktop')
       else
           result:='C:';
       finally
           closekey;
           free;
       end;
       except
           result:='C:';
       end;
   end
end;


procedure TForm1.Save1Click(Sender: TObject);
begin
    if firstsave or (filename='') then
       saveas1click(self)
   else begin
        richedit1.lines.savetofile(filename);
       firstsave:=false;
   end;

end;

procedure checkforstop;
begin
    application.processmessages;
       if stop then begin
           stop:=false;
           abort;
       end;
end;



procedure TForm1.Edit1Click(Sender: TObject);
begin
    paste1.enabled:=activecontrol=cbxKey;
end;

procedure TForm1.Paste1Click(Sender: TObject);
begin
//    cbxKey.pastefromclipboard;
end;

procedure TForm1.Bold1Click(Sender: TObject);
begin
    with bold1 do checked:=not checked;
    setBold;
end;
procedure TForm1.BackupRegistry1Click(Sender: TObject);
var
//certain functions are unreliable with typecast long strings, hence a pchar :
   pwindir : pchar;
   windir : string;
   mess : string;
   ret1,ret2 : bool;
   source,dest : string;
begin
//it would have been nice to have used TFileOperation component (from DSP) but
//error checking was inadequate.
    getmem(pwindir,MAX_PATH+1);
   try
       getwindowsdirectory(pwindir,MAX_PATH);
       winDir:=strpas(pwindir);
       {$i+}
       if not directoryexists(windir+'\regbackup') then
           mkdir(windir+'\regbackup');

         filesetattr(windir+'\regbackup\user.dat',0);
         filesetattr(windir+'\regbackup\system.dat',0);

       source:=windir+'\system.dat';
       dest:=windir+'\regbackup\system.dat';
       ret1:=copyfile(pchar(source),pchar(dest),false);

       source:=windir+'\user.dat';
       dest:=windir+'\regbackup\user.dat';
       ret2:=copyfile(pchar(source),pchar(dest),false);

       //copy across restore instructions
       source:=extractfilepath(paramstr(0))+'\restore.txt';
       dest:=windir+'\regbackup\restore.txt';
       copyfile(pchar(source),pchar(dest),false);

         filesetattr(windir+'\regbackup\user.dat',0);
         filesetattr(windir+'\regbackup\system.dat',0);

        if (ret1=false) or (ret2=false) then
           raise exception.create('Could not backup registry')
       else begin
            mess:='Registry saved to : '+windir+'\regbackup';
           application.messagebox(pchar(mess),'Registry Backup',mb_OK);
       end;
   finally
       freemem(pwindir,MAX_PATH+1);
   end;

end;

procedure TForm1.HelpTopics1Click(Sender: TObject);
begin
    application.helpcontext(10);
end;

procedure TForm1.cbxMaxDepthChange(Sender: TObject);
begin
    maxDepth:=cbxmaxdepth.text;
end;

procedure TForm1.Stop1Click(Sender: TObject);
begin
    stop:=true;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin

    if (ssAlt in shift) and ((key=byte('s')) or (key=byte('S'))) then
       stop:=true;
end;

procedure TForm1.Find1Click(Sender: TObject);
begin
    if inputquery('Find','Text to find',SearchWord)  and (searchword<>'') then
       findWord;
end;

procedure Tform1.findWord;
var
    beforeSearchPos,SearchPos : integer;
begin

    if searchWord='' then begin
        find1click(self);
       exit;
   end;
   with richedit1 do begin
       selstart:=selstart+sellength;
       beforeSearchPos:=selstart+sellength;
       SearchPos:=findtext(searchword,selstart,length(text)-selstart,[]);
       sendMessage(handle,EM_SETSEL,searchPos,SearchPos+length(searchword));
       Refresh;
       setfocus;

       if beforeSearchPos=(selstart+sellength) then
           raise exception.create('Not found');
   end;

end;


procedure TForm1.FindNext1Click(Sender: TObject);
begin
    findword;
end;

procedure TForm1.Exit1Click(Sender: TObject);
begin
stop:=true;
close;
end;

procedure TForm1.Copy2Click(Sender: TObject);
begin
    richedit1.copytoclipboard;
end;

procedure TForm1.EditPopUpPopup(Sender: TObject);
begin
    copy2.enabled:=richedit1.sellength>0;
end;

procedure TForm1.setBold;
begin
 with bold1 do begin
   if checked then
        richedit1.font.style:=[fsbold]+richedit1.font.style
    else
          richedit1.font.style:=richedit1.font.style-[fsbold];
 end;
end;

end.